home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / defsystem.l < prev    next >
Lisp/Scheme  |  1989-07-12  |  13KB  |  355 lines
  1. ;;; -*- Mode:Lisp; Package:USER; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                   P.O. BOX 2909                                  |
  8. ;;;                                AUSTIN, TEXAS 78769                               |
  9. ;;;                                                                                  |
  10. ;;;          Copyright (C) 1987, 1988, 1989 Texas Instruments Incorporated.          |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. (in-package 'user)
  23.  
  24. #-lispm
  25. (progn                        ; SITE DEPENDENT
  26.   ;; NOTE: All pathname strings must end in /*
  27.   (defvar *clx-directory*  "/usr/X11/lib/CLX/*")
  28.   (defvar *clos-kludge-directory*)
  29.   (defvar *clue-directory* nil)
  30.   (defvar *clue-examples-directory* nil)
  31.   (defvar *clue-demo-directory* nil)
  32.   )
  33. #+lispm
  34. (progn                        ; Lispm's have logical pathnames
  35.   (defvar *clx-directory*  "clx:clx;")
  36.   (defvar *clue-directory* "clue:clue;")
  37.   (defvar *clos-kludge-directory*  "clue:clos-kludge;")
  38.   (defvar *clue-examples-directory* "clue:examples;")
  39.   (defvar *clue-demo-directory* "clue:examples.old.demo;")
  40.   )
  41.  
  42. #+comment
  43. ;; Here's a recommended set of LISPM logical pathname translations:
  44. (fs:set-logical-pathname-host "CLUE" :physical-host si:local-host
  45.                   :translations 
  46.                   '(("CLUE" "CLUE;")
  47.                 ("EXAMPLES" "CLUE.EXAMPLES;")
  48.                 ("DOC" "CLUE.DOC;")
  49.                 ("CLOS-KLUDGE" "CLUE.CLOS-KLUDGE;")
  50.                 ))
  51.  
  52. ;; Ensure VALUES is a legal declaration
  53. (proclaim '(declaration values))
  54.  
  55. ;; Ensure *features* knows about CLOS and PCL
  56. (when (find-package 'pcl)
  57.   (pushnew :pcl  *features*)
  58.   (pushnew :clos *features*))
  59.  
  60. (when (find-package 'clos)
  61.   (pushnew :clos *features*))
  62.  
  63. ;; Ensure *features* knows about the Common Lisp Error Handler
  64. (when (find-package 'conditions)
  65.   (pushnew :cleh *features*))
  66.  
  67. ;;;-----------------------------------------------------------------------------
  68. ;;; DEFSYSTEM forms, to make things easy for lispm users
  69.  
  70. #+explorer
  71. (defsystem clue
  72.   (:pathname-default "sys:clue;")
  73.   (:warnings-pathname-default "sys:cwarns;clue.lisp")
  74.   (:patchable "sys:patch.clue;")
  75.   (:initial-status :experimental)
  76.  
  77.   (:module clue       "clue")
  78.   (:module clx-macros ("sys:clx;macros" "sys:clx;bufmac"))
  79.   (:module clx-patch  ("clx-patch" "window-doc" "gc-cache"))
  80.   (:module defcontact "defcontact")
  81.   (:module events     "events")
  82.   (:module intrinsics "intrinsics")
  83.   (:module package    "package")
  84.   (:module resource   ("resource" "gray" "cursor"))
  85.   (:module root-gmgmt "root-gmgmt")
  86.   (:module shells     "shells")
  87.   (:module stream     "stream")
  88.   (:module virtual    "virtual")
  89.   (:module obsolete   "obsolete")
  90.   
  91.   (:module extras     ("clos-patch" "defsys" "pcl-patches" "clx-resource"))
  92.   (:module doc        ("sys:clue.doc;release-notes.text"))
  93.  
  94.   (:auxiliary extras)
  95.   (:auxiliary doc)
  96.  
  97.   (:compile-load clue)
  98.   (:skip :fasload clx-macros)
  99.   (:compile-load clx-patch
  100.          (:fasload clue clx-macros))
  101.   (:compile-load defcontact
  102.          (:fasload clue clx-patch))
  103.   (:compile-load intrinsics
  104.          (:fasload clue clx-patch defcontact))
  105.   (:compile-load resource
  106.          (:fasload clue defcontact intrinsics))
  107.   (:compile-load events
  108.          (:fasload clue clx-patch defcontact intrinsics))
  109.   (:compile-load virtual
  110.          (:fasload clue defcontact intrinsics resource events))
  111.   (:compile-load shells
  112.          (:fasload clue defcontact intrinsics resource events))
  113.   (:compile-load stream
  114.          (:fasload clue defcontact intrinsics resource events))
  115.   (:compile-load root-gmgmt
  116.          (:fasload clue defcontact intrinsics events shells))
  117.   (:compile-load package
  118.          (:fasload
  119.            clue defcontact events intrinsics resource root-gmgmt
  120.            shells stream virtual))
  121.   (:compile-load obsolete
  122.          (:fasload package)))           
  123.  
  124. #+symbolics
  125. (defsystem clue
  126.   (:default-pathname "clue:clue;"
  127.    :pretty-name "CLUE"
  128.    :distribute-binaries t
  129.    :initial-status :experimental
  130.    :bug-reports ("clue-bugs@dsg.csc.ti.com" "Report problems with CLUE.")
  131.    )
  132.   (:module clue ("clue"))
  133.   (:module clx-macros ("clx:clx;macros" "clx:clx;bufmac")
  134.        (:root-module nil))
  135.   (:module clx-patch ("clx-patch" "window-doc" "gc-cache")
  136.        (:uses-definitions-from clue)
  137.        (:uses-definitions-from clx-macros))
  138.   (:serial clue clx-patch "defcontact" "intrinsics" "resource"
  139.        "events" "root-gmgt" "virtual"
  140.        "shells" "stream"
  141.        "gray" "cursor" "package"
  142.        ;; "button" "menu" ;; Moved to Examples
  143.        )
  144.   )
  145.  
  146. ;;;-----------------------------------------------------------------------------
  147. ;;; Simple lisp make facility
  148.  
  149. (defvar *source-binary-extension-alist*
  150.     (or (car
  151.           '(#+symbolics                         ("lisp"  "bin")
  152.         #+(and dec common vax (not ultrix)) ("LSP"   "FAS")
  153.         #+(and dec common vax ultrix)       ("lsp"   "fas")
  154.         #+kcl                               ("lsp"   "o")
  155.         #+xerox                             ("lisp"  "dfasl")
  156.         #+(and lucid mc68000)               ("lisp"  "lbin")
  157.         #+(and lucid vax vms)               ("lisp"  "vbin")
  158.         #+(and lucid prime)                 ("lisp"  "pbin")
  159.         #+(and lucid sunrise)               ("lisp"  "sbin")
  160.         #+(and lucid ibm-rt-pc)             ("lisp"  "bbin")
  161.         #+(and excl allegro)                ("lisp"  "fasl")
  162.         #+(and excl (not allegro))          ("cl"    "fasl")
  163.         #+:cmu                              ("slisp" "sfasl")
  164.         #+hp                                ("l"     "b")
  165.         #+explorer ("lisp" #.(string (si::local-binary-file-type)))
  166.         #+:gclisp                           ("LSP"   "F2S")
  167.         #+pyramid                           ("clisp" "o")
  168.         #+:coral                            ("lisp"  "fasl")
  169.         ))
  170.         '("l" "lbin")))
  171.  
  172. (defun compile-load (file &optional option)
  173.   "Compile file when needed, then load it.
  174.  Recompile when OPTION is :RECOMPILE, load-only when OPTION is LOAD."
  175.   (declare (type (or string pathname) file))
  176.   (check-type option (or null (member :load :compile :recompile)))
  177.   (labels ((make-path (file type)
  178.          (make-pathname
  179.            :type (ecase type
  180.                (:default "l")
  181.                (:source (car *source-binary-extension-alist*))
  182.                (:binary (cadr *source-binary-extension-alist*)))
  183.            :defaults file)))
  184.  
  185.     (let* ((path (parse-namestring file))
  186.        (source (make-path path :source))
  187.        (binary (make-path path :binary)))
  188.       (declare (type pathname path source binary))
  189.       (unless (probe-file source)
  190.     (setq source (make-path file :default)))
  191.       (when (and (not (eq option :load))
  192.          (or (eq option :recompile)
  193.              (not (probe-file binary))
  194.              (> (or (file-write-date source) 1)
  195.             (or (file-write-date binary) 0))))
  196.     (format t "~&; Compiling ~A" source)
  197.     (compile-file source))
  198.       #+explorer(si:load-if binary :verbose t)        ; Load file only if needed.
  199.       #-explorer(format t "~&; Loading   ~A" binary)    ; Is there a way to do this
  200.       #-explorer(load binary :verbose nil)        ; with other systems?
  201.       )))
  202.  
  203. (defun directory-append (pathname sub-directory)
  204.   ;; Return PATHNAME with sub-directory appended to its directory list.
  205.   (declare (type (or string pathname) pathname)
  206.        (type string sub-directory)
  207.        (values pathname))
  208.   ;; This assumes that #'pathname-directory returns a list of sub-directory strings
  209.   (make-pathname
  210.     :defaults pathname
  211.     :directory (append (pathname-directory pathname) (list sub-directory))))
  212.  
  213. ;;;-----------------------------------------------------------------------------
  214. ;;; Compile/Load CLUE
  215.  
  216. (defun compile-clue (&key (option :compile)
  217.              (clue (or *clue-directory* *default-pathname-defaults*))
  218.              (clx *clx-directory*)
  219.              clos-kludge)
  220.   ;; Load CLUE, optionally compiling changed files.
  221.   ;; If OPTION is :RECOMPILE, recompile all files
  222.   ;; If OPTION is :LOAD, don't compile anything, just load.
  223.   ;; WARNING: CLX (and CLOS) MUST BE LOADED FIRST!!!
  224.   (declare (type (or string pathname) clue clx)
  225.        (type (or null string pathname) clos-kludge)
  226.        (type (or null (member :load :compile :recompile)) option))
  227.   (setq *clue-directory* clue            ; Set defaults for the next time
  228.     *clx-directory*  clx)
  229.   (when clos-kludge (setq *clos-kludge-directory* clos-kludge))
  230.   (flet ((module (file &optional opt dir)
  231.        (compile-load (merge-pathnames file (or dir clue)) (or opt option))))
  232.  
  233.     ;; ensure CLX is loaded
  234.     (unless (find-package 'xlib)
  235.       (compile-clos-clx :option option))
  236.  
  237.     ;; ensure CLOS is loaded
  238.     (unless (member :clos *features*)
  239.       ;; No CLOS, load clos-kludge
  240.       (unless (boundp '*clos-kludge-directory*)
  241.     ;; Build a pathname to the clos-kludge directory
  242.     (setq *clos-kludge-directory* (directory-append clue "clos-kludge")))
  243.       (module "defsystem" option *clos-kludge-directory*)
  244.       (compile-clos-kludge option))
  245.  
  246.     ;; These CLX files must be loaded to compile CLUE
  247.     (unless (eq option :load)
  248.       (module "macros" :load clx)
  249.       (module "bufmac" :load clx))
  250.  
  251.     (module "clue")        ;; Define packages
  252.     (module "clx-patch")    ;; Modify xlib:create-window
  253.     (module "window-doc")    ;; pointer documentation window support
  254.     (module "gc-cache")        ;; CLX using-gcontext
  255.     (module "defcontact")    ;; CLOS extension for resources and type conversion
  256.     (module "intrinsics")    ;; The "guts"
  257.     (module "resource")        ;; Resource and type conversion
  258.     (module "gray")        ;; Gray stipple patterns
  259.     (module "cursor")        ;; Standard cursor names
  260.     (module "events")        ;; Event handling
  261.     (module "root-gmgmt")    ;; Geometry management methods for root contacts
  262.     (module "virtual")        ;; Support for windowless contacts
  263.     (module "shells")        ;; Support for top-level window/session mgr interaction
  264. ;;  (module "stream")        ;; interactive-stream (non-portable!!)
  265.     (module "package")        ;; External cluei symbols exported from clue
  266.  
  267. ;;    (module "button")        ;; label and button contacts
  268. ;;    (module "menu")        ;; menu contacts
  269. ;; Note: moved to examples
  270.     ))
  271.  
  272. (defun load-clue (&rest options)
  273.   ;; Load CLUE
  274.   ;; WARNING: CLX MUST BE LOADED FIRST!!!
  275.   (apply #'compile-clue :option :load options))
  276.  
  277. (defun compile-clue-all (&rest options &key option &allow-other-keys)
  278.   ;; Compile CLUE, clue-examples and clue-demo
  279.   (apply #'compile-clue options)
  280.   (unless *clue-examples-directory*
  281.     (setq *clue-examples-directory* (directory-append *clue-directory* "examples")))
  282.   (load (merge-pathnames "defsystem" *clue-examples-directory*))
  283.   (compile-clue-examples option)
  284.   (unless *clue-demo-directory*
  285.     (setq *clue-demo-directory* (directory-append *clue-directory* "demo")))
  286.   (load (merge-pathnames "defsystem" *clue-demo-directory*))
  287.   (compile-clue-demo option))
  288.  
  289. ;;;-----------------------------------------------------------------------------
  290. ;;; Compile/Load CLX with CLOS patches
  291.  
  292. (defun compile-clos-clx (&key (option :compile)
  293.              (clue *clue-directory*)
  294.              (clx *clx-directory*))
  295.   ;; Load CLX, optionally compiling changed files.
  296.   ;; If OPTION is :RECOMPILE, recompile all files
  297.   ;; If OPTION is :LOAD, don't compile anything, just load.
  298.   (declare (type (or string pathname) clue clx)
  299.        (type (or null (member :load :compile :recompile)) option))
  300.   (setq *clue-directory* clue            ; Set defaults for the next time
  301.     *clx-directory*  clx)
  302.   (flet ((module (file &optional opt dir)
  303.          (compile-load (merge-pathnames file (or dir clx)) (or opt option))))
  304.     
  305. ;;    #+pcl
  306. ;;    (module "pcl-patch" option clue)        ; Ensure PCL patches are loaded
  307.     #+lucid
  308.     (progn
  309.       (module "make-sequence-patch")
  310.       (clx-foreign-files))
  311.     #+kcl
  312.     (module "tcp/tcpinit")
  313.     #+excl
  314.     (module "excldep")
  315.     (module "depdefs")
  316.     (module "clx")
  317.     (module "dependent")
  318.     (module "clos-patch" option clue)        ; Patch CLX to use CLOS defclass
  319.     (unless (eq option :load)
  320.       (module "macros")
  321.       (module "bufmac"))
  322.     (module "buffer")
  323.     (module "display")
  324.     (module "gcontext")
  325.     (module "requests")
  326.     (module "input")
  327.     (module "fonts")
  328.     (module "graphics")
  329.     (module "text")
  330.     (module "attributes")
  331.     (module "translate")
  332.     (module "keysyms")
  333.     (module "manager")
  334.     (module "image")
  335.     (module "resource")
  336.     ))
  337.  
  338. (defun load-clos-clx (&rest options)
  339.   ;; Load CLX
  340.   (apply #'compile-clos-clx :option :load options))
  341.  
  342. #+lucid
  343. (defvar *foreign-libraries* '("-lc")) ; '("-lresolv" "-lc") for some sites
  344.  
  345. #+lucid
  346. (defun clx-foreign-files ()
  347.   (define-c-function (xlib::connect-to-server "_connect_to_server")
  348.              (host display)
  349.              :result-type :integer)
  350.   (unintern 'display)
  351.   (load-foreign-files '("socket.o") *foreign-libraries*))
  352.  
  353. ;; End of file
  354.  
  355.